home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / apollot.lha / apollot_sr10 / tfix5.t < prev    next >
Text File  |  1989-03-17  |  5KB  |  136 lines
  1. (herald tfix5 (env tsys)
  2.               (syntax-table (env-syntax-table t-implementation-env)))
  3.  
  4. (load-if-present '(tsystem ofix5) orbit-env)
  5.  
  6. ;; scheme eof fix, throw fix, iob-writable? fix
  7.  
  8. (*define (*value standard-env 'scheme-env) 'eof eof)
  9.  
  10. (define (continuation-throw sp stack vals k-state base-state)
  11.   (cond ((stack? stack)
  12.          (let ((a (swap *the-current-throw-value* vals))
  13.                (b (swap *the-current-throw-frame* stack)))
  14.            (unwind-to-top)
  15.            (set *the-current-throw-frame* b)
  16.            (set *the-current-throw-value* a)
  17.            (set (process-global task/dynamic-state) k-state)
  18.            (invoke-continuation sp stack vals base-state k-state)))
  19.         (else
  20.          (error "throwing ~s to bad continuation ~s" vals stack))))
  21.                                   
  22.                              
  23. (define (unwind-to-top)
  24.   (iterate loop ((state (process-global task/dynamic-state)))
  25.     (cond ((eq? state nil))
  26.           ((eq? (state-winder state) false)
  27.        (loop (state-previous state)))
  28.           (else
  29.            (perform-unwind state)
  30.            (loop (state-previous state))))))
  31.  
  32. (define-integrable (iob-writable? iob)
  33.   (or (iob-mode? (iob-mode iob) iob/write)
  34.       (iob-mode? (iob-mode iob) iob/append)))
  35.  
  36. (define (init-buffer buf mode underflow overflow)
  37.   (set (iob-mode        buf) mode)
  38.   (set (iob-offset      buf) 0)
  39.   (set (iob-h           buf) 0)
  40.   (set (iob-prev-h      buf) 0)
  41.   (set (iob-v           buf) 0)
  42.   (set (iob-indent      buf) 0)
  43.   (set (iob-wrap-column buf) standard-wrap-column)
  44.   (set (iob-line-length buf) standard-line-length)
  45.   (set (iob-rt          buf) '#f)
  46.   (set (iob-eof-flag?   buf) '#f)
  47.   (cond ((iob-readable? buf)
  48.          (set (iob-limit     buf) 0)
  49.          (set (iob-underflow buf) underflow)
  50.          (set (iob-overflow  buf) overflow-error))
  51.         ((iob-writable? buf)
  52.          (set (iob-limit     buf) (max-buffer-length buf))
  53.          (set (iob-underflow buf) underflow-error)
  54.          (set (iob-overflow  buf) overflow)))
  55.   buf)
  56.  
  57. (define (CLOSE-PORT iob)
  58.   (let ((iob (enforce iob? iob)))
  59.     (cond ((iob-permanent? iob)
  60.            (nc-error "attempt to close a permanent port - ~a" iob))
  61.           ((iob-closed? iob)
  62.            (no-value))
  63.           (else
  64.            (if (iob-writable? iob) (%vm-write-buffer iob))
  65.            (if (iob-channel iob) (%vm-close-file iob))
  66.         ;++(set (table-entry open-port-table iob) nil)
  67.            (release-buffer-text %buffer-pool iob)
  68.            (set (iob-buffer iob) '#f)
  69.            (set (iob-mode   iob) iob/closed)
  70.            (set (iob-xeno   iob) '#f)
  71.            ;; make it fail in VM-READ-CHAR
  72.            (set (iob-limit  iob) -1)
  73.            (no-value)))))
  74.  
  75. (define (make-default-herald filename)
  76.   (let ((h (make-herald)))
  77.     (set (herald-filename  h) (->filename filename))
  78.     h))
  79.  
  80. (*define (*value standard-env 'scheme-env) 'true true)
  81.  
  82.  
  83. (define (read-inline-comment port ch n rt)
  84.   (ignore ch n rt)
  85.   (let ((readc (if (iob? port) vm-read-char read-char)))
  86.     (labels (((error)
  87.               (read-error port "end of file within #|...|# (missing delimiter)"))
  88.              ((loop level)
  89.               (let ((ch (readc port)))
  90.                 (cond ((eof? ch) (error))
  91.                       ((char= ch #\|)
  92.                        (let ((ch (readc port)))
  93.                          (cond ((eof? ch) (error))
  94.                                ((charn= ch #\#)
  95.                                 (unread-char port)
  96.                                 (loop level))
  97.                                ((fx= level 1)
  98.                                 nothing-read)
  99.                                (else
  100.                                 (loop (fx- level 1))))))
  101.                       ((char= ch #\#)
  102.                        (let ((ch (readc port)))
  103.                          (cond ((eof? ch) (error))
  104.                                ((char= ch #\|)
  105.                                 (loop (fx+ level 1)))
  106.                                (else
  107.                                 (unread-char port)
  108.                                 (loop level)))))
  109.                       (else (loop level))))))
  110.       (loop 1))))
  111.  
  112. (set-dispatch-syntax read-dispatch #\| read-inline-comment)
  113.  
  114. (*define (*value standard-env 'scheme-env) 'cond-=>-aux cond-=>-aux)
  115.  
  116. ;; from mohr-eric@yale.arpa   march 1989
  117.  
  118. (define aegis-fs?
  119.   (let ((specials '(\/\/ \/ \. \\ \~)))
  120.     (object (lambda (fs) (eq? (fs-type fs) aegis-fs?))
  121.       ((special-symbols self) specials)
  122.       ((massage-logical-name self ln)
  123.        (let ((ln-string (string-downcase (symbol->string ln))))
  124.          (cond ((memq? ln specials)
  125.                 ln-string)
  126.                (else 
  127.                 (string-append "~/" ln-string "/")))))
  128.       ((parse-filespec self fs string)
  129.        (ignore fs)
  130.        (string->filename string #\/ #\.)) 
  131.       ((print self port)
  132.        (format port "#{File-system-type~_AEGIS}")))))
  133.  
  134. (define (the-init-file-directory) "~/")
  135.  
  136.